home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / delphi.swg / 0198_A Better Way To Print a Form.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-11-29  |  7.1 KB  |  251 lines
  1.  
  2.  
  3. The following TI details a better way to print the contents of
  4. a form, by getting the device independent bits in 256 colors
  5. from the form, and using those bits to print the form to the
  6. printer.
  7.  
  8. In addition, a check is made to see if the screen or printer
  9. is a palette device, and if so, palette handling for the device
  10. is enabled. If the screen device is a palette device, an additional
  11. step is taken to fill the bitmap's palette from the system palette,
  12. overcoming some buggy video drivers who don't fill the palette in.
  13.  
  14. Note: Since this code does a screen shot of the form, the form must
  15. be the topmost window and the whole from must be viewable when the
  16. form shot is made.
  17.  
  18.  
  19.  
  20.  
  21. unit Prntit;
  22.  
  23. interface
  24.  
  25. uses
  26.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, 
  27.   Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
  28.  
  29. type
  30.   TForm1 = class(TForm)
  31.     Button1: TButton;
  32.     Image1: TImage;
  33.     procedure Button1Click(Sender: TObject);
  34.   private
  35.     { Private declarations }
  36.   public
  37.     { Public declarations }
  38.   end;
  39.  
  40. var
  41.   Form1: TForm1;
  42.  
  43. implementation
  44.  
  45. {$R *.DFM}
  46.  
  47.  
  48. uses Printers;
  49.  
  50.  
  51. procedure TForm1.Button1Click(Sender: TObject);
  52. var
  53.   dc: HDC;
  54.   isDcPalDevice : BOOL;
  55.   MemDc :hdc;
  56.   MemBitmap : hBitmap;
  57.   OldMemBitmap : hBitmap;
  58.   hDibHeader : Thandle;
  59.   pDibHeader : pointer;
  60.   hBits : Thandle;
  61.   pBits : pointer;
  62.   ScaleX : Double;
  63.   ScaleY : Double;
  64.   ppal : PLOGPALETTE;
  65.   pal : hPalette;
  66.   Oldpal : hPalette;
  67.   i : integer;
  68. begin
  69.  {Get the screen dc}
  70.   dc := GetDc(0);
  71.  {Create a compatible dc}
  72.   MemDc := CreateCompatibleDc(dc);
  73.  {create a bitmap}
  74.   MemBitmap := CreateCompatibleBitmap(Dc, 
  75.                                       form1.width, 
  76.                                       form1.height);
  77.  {select the bitmap into the dc}
  78.   OldMemBitmap := SelectObject(MemDc, MemBitmap);
  79.  
  80.  {Lets prepare to try a fixup for broken video drivers}
  81.   isDcPalDevice := false;
  82.   if GetDeviceCaps(dc, RASTERCAPS) and 
  83.      RC_PALETTE = RC_PALETTE then begin
  84.     GetMem(pPal, sizeof(TLOGPALETTE) + 
  85.       (255 * sizeof(TPALETTEENTRY)));
  86.     FillChar(pPal^, sizeof(TLOGPALETTE) + 
  87.       (255 * sizeof(TPALETTEENTRY)), #0);
  88.     pPal^.palVersion := $300;
  89.     pPal^.palNumEntries := 
  90.       GetSystemPaletteEntries(dc,
  91.                               0,
  92.                               256,
  93.                               pPal^.palPalEntry);
  94.     if pPal^.PalNumEntries <> 0 then begin
  95.       pal := CreatePalette(pPal^);
  96.       oldPal := SelectPalette(MemDc, Pal, false);
  97.       isDcPalDevice := true
  98.     end else
  99.     FreeMem(pPal, sizeof(TLOGPALETTE) + 
  100.            (255 * sizeof(TPALETTEENTRY)));
  101.   end;
  102.  
  103.  {copy from the screen to the memdc/bitmap}
  104.   BitBlt(MemDc,
  105.          0, 0,
  106.          form1.width, form1.height,
  107.          Dc,
  108.          form1.left, form1.top,
  109.          SrcCopy);
  110.  
  111.   if isDcPalDevice = true then begin
  112.     SelectPalette(MemDc, OldPal, false);
  113.     DeleteObject(Pal);
  114.   end;
  115.  
  116.  {unselect the bitmap}
  117.   SelectObject(MemDc, OldMemBitmap);
  118.  {delete the memory dc}
  119.   DeleteDc(MemDc);
  120.  {Allocate memory for a DIB structure}
  121.   hDibHeader := GlobalAlloc(GHND,
  122.                             sizeof(TBITMAPINFO) +
  123.                             (sizeof(TRGBQUAD) * 256));
  124.  {get a pointer to the alloced memory}
  125.   pDibHeader := GlobalLock(hDibHeader);
  126.  
  127.  {fill in the dib structure with info on the way we want the DIB}
  128.   FillChar(pDibHeader^, 
  129.            sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256), 
  130.            #0);
  131.   PBITMAPINFOHEADER(pDibHeader)^.biSize := 
  132.     sizeof(TBITMAPINFOHEADER);
  133.   PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
  134.   PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
  135.   PBITMAPINFOHEADER(pDibHeader)^.biWidth := form1.width;
  136.   PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
  137.   PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
  138.  
  139.  {find out how much memory for the bits}
  140.   GetDIBits(dc,
  141.             MemBitmap,
  142.             0,
  143.             form1.height,
  144.             nil,
  145.             TBitmapInfo(pDibHeader^),
  146.             DIB_RGB_COLORS);
  147.  
  148.  {Alloc memory for the bits}
  149.   hBits := GlobalAlloc(GHND, 
  150.                        PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
  151.  {Get a pointer to the bits}
  152.   pBits := GlobalLock(hBits);
  153.  
  154.  {Call fn again, but this time give us the bits!}
  155.   GetDIBits(dc,
  156.             MemBitmap,
  157.             0,
  158.             form1.height,
  159.             pBits,
  160.             PBitmapInfo(pDibHeader)^,
  161.             DIB_RGB_COLORS);
  162.  
  163.  {Lets try a fixup for broken video drivers}
  164.   if isDcPalDevice = true then begin
  165.     for i := 0 to (pPal^.PalNumEntries - 1) do begin
  166.       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := 
  167.         pPal^.palPalEntry[i].peRed;
  168.       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen :=
  169.         pPal^.palPalEntry[i].peGreen;
  170.       PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue :=
  171.         pPal^.palPalEntry[i].peBlue;
  172.     end;
  173.     FreeMem(pPal, sizeof(TLOGPALETTE) +
  174.            (255 * sizeof(TPALETTEENTRY)));
  175.   end;
  176.  
  177.  {Release the screen dc}
  178.   ReleaseDc(0, dc);
  179.  {Delete the bitmap}
  180.   DeleteObject(MemBitmap);
  181.  
  182.  {Start print job}
  183.   Printer.BeginDoc;
  184.  
  185.  {Scale print size}
  186.   if Printer.PageWidth < Printer.PageHeight then begin
  187.    ScaleX := Printer.PageWidth;
  188.    ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
  189.   end else begin
  190.    ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
  191.    ScaleY := Printer.PageHeight;
  192.   end;
  193.  
  194.  
  195.  {Just incase the printer drver is a palette device}
  196.   isDcPalDevice := false;
  197.   if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
  198.       RC_PALETTE = RC_PALETTE then begin
  199.    {Create palette from dib}
  200.     GetMem(pPal, sizeof(TLOGPALETTE) +
  201.           (255 * sizeof(TPALETTEENTRY)));
  202.     FillChar(pPal^, sizeof(TLOGPALETTE) + 
  203.           (255 * sizeof(TPALETTEENTRY)), #0);
  204.     pPal^.palVersion := $300;
  205.     pPal^.palNumEntries := 256;
  206.     for i := 0 to (pPal^.PalNumEntries - 1) do begin
  207.       pPal^.palPalEntry[i].peRed := 
  208.         PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
  209.       pPal^.palPalEntry[i].peGreen := 
  210.         PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
  211.       pPal^.palPalEntry[i].peBlue := 
  212.         PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
  213.     end;
  214.     pal := CreatePalette(pPal^);
  215.     FreeMem(pPal, sizeof(TLOGPALETTE) + 
  216.             (255 * sizeof(TPALETTEENTRY)));
  217.     oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
  218.     isDcPalDevice := true
  219.   end;
  220.  
  221.  {send the bits to the printer}
  222.   StretchDiBits(Printer.Canvas.Handle,
  223.                 0, 0,
  224.                 Round(scaleX), Round(scaleY),
  225.                 0, 0,
  226.                 Form1.Width, Form1.Height,
  227.                 pBits,
  228.                 PBitmapInfo(pDibHeader)^,
  229.                 DIB_RGB_COLORS,
  230.                 SRCCOPY);
  231.  
  232.  {Just incase you printer drver is a palette device}
  233.   if isDcPalDevice = true then begin
  234.     SelectPalette(Printer.Canvas.Handle, oldPal, false);
  235.     DeleteObject(Pal);
  236.   end;
  237.  
  238.  
  239.  {Clean up allocated memory}
  240.   GlobalUnlock(hBits);
  241.   GlobalFree(hBits);
  242.   GlobalUnlock(hDibHeader);
  243.   GlobalFree(hDibHeader);
  244.  
  245.  
  246.  {End the print job}
  247.   Printer.EndDoc;
  248.  
  249.  
  250. end;
  251.